home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / TOOLPAS2 / ERRTRAP.PAS < prev    next >
Pascal/Delphi Source File  |  1991-10-08  |  4KB  |  142 lines
  1.  
  2. (*
  3.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13. (*
  14.  * Runtime error handler - traps and reports runtime errors
  15.  * with full messages. (3-1-89)
  16.  *
  17.  *)
  18.  
  19. unit ErrTrap;
  20.  
  21. {$F+,R-,S-}
  22.  
  23. interface
  24.  
  25.    var
  26.       ExitSave: pointer;   {pointer to next exitproc in the chain}
  27.  
  28.    procedure error_handler;
  29.    function itoh(w: word): string;
  30.    function error_message(code: integer): string;
  31.  
  32.  
  33. implementation
  34.  
  35.    function error_message(code: integer): string;
  36.       {return message text for a given runtime error code}
  37.    var
  38.       class:  string;
  39.       msg:    string;
  40.    begin
  41.       case code of
  42.            1.. 99: class := 'DOS';
  43.          100..149: class := 'I/O';
  44.          150..199: class := 'CRITICAL';
  45.          200..249: class := 'FATAL';
  46.          else      class := 'UNKNOWN';
  47.       end;
  48.  
  49.       case code of
  50.            2: msg := 'File not found';
  51.            3: msg := 'Path not found';
  52.            4: msg := 'Too many open files';
  53.            5: msg := 'File access denied';
  54.            6: msg := 'Bad file handle';
  55.          { 8: msg := 'Not enough memory'; }
  56.           12: msg := 'Bad file access code';
  57.           15: msg := 'Bad drive number';
  58.           16: msg := 'Can''t remove current dir';
  59.           17: msg := 'Can''t rename across drives';
  60.  
  61.          100: msg := 'Disk read error';
  62.          101: msg := 'Disk write error';
  63.          102: msg := 'File not assigned';
  64.          103: msg := 'File not open';
  65.          104: msg := 'File not open for input';
  66.          105: msg := 'File not open for output';
  67.          106: msg := 'Bad numeric format';
  68.  
  69.          150: msg := 'Disk is write-protected';
  70.          151: msg := 'Unknown diskette unit';
  71.          152: msg := 'Drive not ready';
  72.          153: msg := 'Unknown command';
  73.          154: msg := 'CRC error in data';
  74.          155: msg := 'Bad drive request structure length';
  75.          156: msg := 'Disk seek error';
  76.          157: msg := 'Unknown diskette type';
  77.          158: msg := 'Sector not found';
  78.          159: msg := 'Printer out of paper';
  79.          160: msg := 'Device write fault';
  80.          161: msg := 'Device read fault';
  81.          162: msg := 'Hardware failure';
  82.  
  83.          200: msg := 'Division by zero';
  84.          201: msg := 'Range check';
  85.          202: msg := 'Stack overflow';
  86.          203: msg := 'Heap overflow';
  87.          204: msg := 'Bad pointer operation';
  88.          205: msg := 'Floating point overflow';
  89.          206: msg := 'Floating point underflow';
  90.          207: msg := 'Bad floating point operation';
  91.  
  92.          else str(code,msg);
  93.       end;
  94.  
  95.       error_message := class + ' ERROR: ' + msg;
  96.    end;
  97.  
  98.  
  99.    function itoh(w: word): string;
  100.       {hex conversion}
  101.    const
  102.       hex: array[0..15] of char = '0123456789ABCDEF';
  103.    var
  104.       h: string[4];
  105.    begin
  106.       h[0] := chr(4);
  107.       h[1] := hex[(w shr 12) and $0F];
  108.       h[2] := hex[(w shr  8) and $0F];
  109.       h[3] := hex[(w shr  4) and $0F];
  110.       h[4] := hex[w          and $0F];
  111.       itoh := h;
  112.    end;
  113.  
  114.  
  115.    procedure error_handler;
  116.       {exit handler, checks for I/O and runtime errors}
  117.    begin
  118.       {link to the next exitproc when this one's finished}
  119.       ExitProc := ExitSave;
  120.  
  121.       {all finished unless there is an error}
  122.       if ErrorAddr = nil then
  123.          exit;
  124.  
  125.       {generate error message text and clear the error condition}
  126.       writeln(^G);
  127.       writeln('▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒');
  128.       writeln('▒▒▒▒▒      Runtime error ',ExitCode:3,' at location ',
  129.               itoh(seg(ErrorAddr^)),':',itoh(ofs(ErrorAddr^)),  '     ▒▒▒▒▒');
  130.       writeln('▒▒▒▒▒':60,^M'▒▒▒▒▒      ',error_message(ExitCode));
  131.       writeln('▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒');
  132.       ErrorAddr := nil;
  133.    end;
  134.  
  135.  
  136. (* install new runtime error handler *)
  137. begin
  138.    ExitSave := ExitProc;        {save link to next handler in chain}
  139.    ExitProc := @error_handler;  {link in my handler}
  140. end.
  141.  
  142.